COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 -*- LISP -*-
C00003 00003
C00006 00004
C00008 00005
C00009 ENDMK
C⊗;
;;; -*- LISP -*-
;;;; Advice internals:

(eval-when (compile) (load "scm:umacro"))
(eval-when (compile) (load "scm:smacro"))
(eval-when (compile) (load "scm:amacro"))
(herald advice "")


;;;; Advising procedure:

(defmacro add-to-advised-list (proc)
  `(let ((adlist (relative-lexical-access nil '*advised-procedures*)))
     (if (memq ,proc adlist) nil
	 (relative-lexical-assign nil '*advised-procedures*
				  (cons ,proc adlist)))))

(defmacro copylist (a-list)
  `(append ,a-list nil))

(defmacro remove-from-advised-list (proc)
  `(let ((adlist (relative-lexical-access nil '*advised-procedures*)))
     (relative-lexical-assign nil '*advised-procedures*
				  (delete ,proc (copylist adlist)))))

(defun sch-advise (proc advice advice-remembered type)
                                         ;type can be entry, exit or wrap.
  (if (not (applicable? proc))
      (sch-error "Bad procedure to advise" proc)
      (let ((original (copy-hunk proc)))
	(set-procedure-class proc '*procedure*)
	(set-procedure-object proc (advise-wrap advice original type))
	(set-procedure-name proc
			    (make-advice-name (sch-procedure-name proc)
					      advice-remembered
					      original
					      type))
	(add-to-advised-list proc)
	proc)))

(defun advise-wrap (advice proc type)
   (let ((forced-lexpr-arg?
	  (or (eq type 'wrap)
	      (eq (primitive-type proc) 'primitive-procedure))))
     (let ((args (if forced-lexpr-arg? 
		     (gensym)
		     (direct-procedure-formals proc))))
       (let ((lexpr-arg? (or forced-lexpr-arg? (symbolp args))))
	 (cdr (syntax
	       `(lambda ,args
		  (',advice ',proc ,(if lexpr-arg?
					args
					'(the-arguments))
			    (the-environment)))))))))



;;;; Unadvise:

(defmacro remove-this-advice-level (advised-proc)
  `(set-hunk ,advised-proc
	     (advised-proc (procedure-name ,advised-proc))))

(declare (special advice-to-match))
(declare (special type-to-match))


(defun unadvise-particular-type (proc type-to-match)
  (unadvise proc
		 #'(lambda (name-object)
		     (eq (advise-type name-object) type-to-match))))

(defun unadvise-particular-advice (proc advice-to-match)
  (unadvise proc
	    #'(lambda (name-object)
		(eq (advised-advice name-object) advice-to-match))))

(defun unadvise-completely (proc)
  (unadvise proc #'(lambda (name-object) T)))

(defun unadvise (proc filter)
  (cond ((applicable? proc)
	 (unadvise-loop proc filter)
	 (if (not (advised? proc))
	     (remove-from-advised-list proc))
	 proc)
	(t (sch-error "Bad procedure to unadvise" proc))))

(defun unadvise-loop (level filter)
  (cond ((not (advised? level))
	 level)
	((funcall filter (procedure-name level))
	 (remove-this-advice-level level)
	 (unadvise-loop level filter))
	((unadvise-loop (advised-proc (procedure-name level)) filter))))


;;;; Advice:

(defun advice (proc)
  (cond ((not (advised? proc))
	 nil)
	(t (cons (advised-advice (procedure-name proc))
		 (advice (advised-proc (procedure-name proc)))))))